home *** CD-ROM | disk | FTP | other *** search
/ SGI Hot Mix 17 / Hot Mix 17.iso / HM17_SGI / research / lib / obsolete / tiff_write.pro < prev    next >
Text File  |  1997-07-08  |  9KB  |  261 lines
  1. ; $Id: tiff_write.pro,v 1.2 1997/01/15 04:02:19 ali Exp $
  2. ;
  3. ; Copyright (c) 1991-1997. Research Systems, Inc. All rights reserved.
  4. ;    Unauthorized reproduction prohibited.
  5. ;+
  6. ; NAME:
  7. ;    TIFF_WRITE
  8. ;
  9. ; PURPOSE:
  10. ;    Write images in TIFF format.
  11. ;
  12. ; CATEGORY:
  13. ;    Input/output.
  14. ;
  15. ; CALLING SEQUENCE:
  16. ;    TIFF_WRITE, Filename, Array [, Orientation]
  17. ;
  18. ; INPUTS:
  19. ;     Filename:    A string containing the name of file to create. 
  20. ;
  21. ;    Array:    The image data to be written.  If not already a byte array,
  22. ;        it is made a byte array.  Array may be either an
  23. ;        [n, m] array for Grayscale or Palette classes, or
  24. ;        a [3, n, m] array for RGB full color, interleaved
  25. ;        by image.  If the PLANARCONFIG keyword (see below) is set
  26. ;        to 2 then the Array parameter is ignored (and may be
  27. ;        omitted). See PROCEDURE below for more information on
  28. ;        TIFF classes. 
  29. ;
  30. ; OPTIONAL INPUT PARAMETERS:
  31. ; Orientation:    This parameter should be 0 if the image is stored from bottom 
  32. ;        to top (the default).  For images stored from top to bottom, 
  33. ;        this parameter should be 1.  
  34. ;
  35. ;        WARNING:  Not all TIFF readers are capable of reversing the 
  36. ;        scan line order.  If in doubt, first convert the image
  37. ;        to top to bottom order (use the IDL REVERSE() function), and 
  38. ;        set Orientation to 1.
  39. ;
  40. ; OPTIONAL KEYWORD PARAMETERS:
  41. ; RED, GREEN, BLUE:
  42. ;        The color table vectors, scaled from 0 to 255 in the case of 
  43. ;        a Class P, Palette color image.  If, PlanarConfig is 2, these 
  44. ;        parameters must contain the 3 color component image parameters.
  45. ;
  46. ;        LONG:    If set, write the samples as 32 bit signed numbers.
  47. ; PLANARCONFIG:    Set this parameter to 2 if writing an RGB image that is 
  48. ;        contained in three separate images (color planes), specified
  49. ;        in the RED, GREEN, and BLUE parameters.  Otherwise, omit
  50. ;        this parameter (or set it to 1).
  51. ;
  52. ;        SHORT:    If set, write the samples as 16 bit signed numbers.
  53. ;        If neither SHORT or LONG are specified, write samples as
  54. ;        unsigned 8-bit numbers.
  55. ;    XRESOL:    The horizontal resolution, in pixels per inch.  The default
  56. ;        is 100.
  57. ; 
  58. ;    YRESOL:    The vertical resolution, in pixels per inch.  The default
  59. ;        is 100.
  60. ;
  61. ; OUTPUTS:
  62. ;    No explicit inputs.
  63. ;
  64. ; COMMON BLOCKS:
  65. ;    TIFF_COM.  Only for internal use.
  66. ;
  67. ; SIDE EFFECTS:
  68. ;    A file is created and written.
  69. ;
  70. ; RESTRICTIONS:
  71. ;    This procedure writes images in a single strip, or 3 strips when 
  72. ;    PLANARCONFIG is set to 2.  This procedure may cause readers with 
  73. ;    memory limitations problems.
  74. ;
  75. ; PROCEDURE/EXAMPLES:
  76. ;    Four types of TIFF files can be written:
  77. ;
  78. ;    TIFF Class G, Grayscale.  Array contains the 8-bit image array.
  79. ;    A value of 0 is black, 255 is white.  The Red, Green, and Blue
  80. ;    keywords are omitted.  Example:
  81. ;        TIFF_WRITE, 'a.tiff', Array
  82. ;
  83. ;    TIFF Class P, Palette Color.  Array contains the 8-bit image array.  
  84. ;    The keyword parameters RED, GREEN, and BLUE contain the color tables, 
  85. ;    which can have up to 256 elements, scaled from 0 to 255.  Example:
  86. ;        TIFF_WRITE, 'a.tiff', Array, RED = r, GREEN = g, BLUE = b
  87. ;
  88. ;    TIFF Class R, RGB Full Color, color interleaved by pixel.
  89. ;    Array contains the byte data, and is dimensioned [3, cols, rows].
  90. ;    Example:
  91. ;        TIFF_WRITE, 'a.tiff', Array
  92. ;
  93. ;    TIFF Class R, RGB Full Color, color interleaved by image.
  94. ;    Input is three separate images, provided in the keyword
  95. ;    parameters RED, GREEN, and BLUE.  The input parameter "Array"
  96. ;    is ignored.  The keyword PLANARCONFIG must be set to 2 in this case.
  97. ;    Example:
  98. ;        TIFF_WRITE, 'a.tiff', RED = r, GREEN = g, BLUE = b, PLAN = 2
  99. ;
  100. ; MODIFICATION HISTORY:
  101. ;    DMS, Written for VMS in 1985.
  102. ;
  103. ;    DMS, April, 1991.  Rewrote and added class R and P images.
  104. ;    DJC, Nov, 1993.  Fixed doc header.
  105. ;    DMS, Aug, 1995.  Added support for 16 and 32 bit samples.
  106. ;-
  107. pro tiff_add_tag, lun, tag, value  ;Add a tag to the Image File Directory (IFD)
  108. common tiff_com, order, ifd, count
  109.  
  110. s = size(value)        ;Determine type from parameter
  111. typ = s[s[0]+1]        ;IDL type code
  112. tiff_typ = ([ 0, 1, 3, 4, 5, 0, 0, 2])[typ]  ;Tiff types vs IDL
  113. TypeLen = ([0, 1, 1, 2, 4, 8])[tiff_typ]
  114.  
  115. n = s[s[0]+2]        ; # of elements
  116. offset = count * 12 + 2    ; Offset into ifd
  117. ifd[offset] =   byte(fix(tag),0,2)    ;integer tag
  118. ifd[offset+2] = byte(tiff_typ, 0, 2)    ;data type
  119. ifd[offset+4] = byte(n,0,4)        ;count
  120. nbytes = n * TypeLen
  121.  
  122. if nbytes le 4 then begin    ;Simple case
  123.     ifd[offset+8] = byte(value,0,nbytes)
  124. endif else begin        ;Array, written to file
  125.     point_lun, -lun, pos   ;Get file posit
  126.     ifd[offset+8] = byte(pos, 0, 4)  ;Set IFD ^ pointer
  127.     if typ ne 4 then writeu, lun, value $    ;Write the data
  128.     else begin        ;Write floating
  129.         s = lonarr(n * 2)
  130.         s[indgen(n)*2] = value * 10000.  ;Arbritrary scale of 10000
  131.         s[indgen(n)*2+1] = 10000
  132.         writeu,lun, s
  133.     endelse
  134. endelse
  135. count = count + 1
  136. end
  137.  
  138.  
  139. pro tiff_write, filename, array, orientation, $
  140.     Red=red, Green=green, Blue=blue, Long=long, Short=short, $
  141.     PlanarConfig = PlanarConfig, Xresol = Xresol, Yresol = Yresol
  142. common tiff_com, order, ifd, count
  143.  
  144. on_error,2                      ;Return to caller if an error occurs
  145.  
  146. if n_elements(array) gt 0 then array = byte(array) ;Make sure it's byte
  147. s = size(array)
  148. if n_elements(PlanarConfig) le 0 then PlanarConfig = 1
  149.  
  150. color = 0            ;True if palette color with tables
  151.  
  152. if s[0] eq 3 then begin        ;True color image?
  153.     photo = 2
  154.     if s[1] ne 3 then message,'For true-color, image must be (3,n,m)'
  155.     cols = s[2]
  156.     rows = s[3]
  157.     samples = 3        ;3 samples / pixel
  158. endif else if PlanarConfig eq 2 then begin   ;RGB with separate sample planes
  159.     photo = 2
  160.     s = size(red)        ;Take image param from r,g,b
  161.     if s[0] ne 2 then message, 'Parameter must be 2D'
  162.     cols = s[1]
  163.     rows = s[2]
  164.     samples = 3
  165.     if (n_elements(red) ne n_elements(green)) or $
  166.         (n_elements(red) ne n_elements(blue)) then $
  167.         message,'Image components must have same size'
  168. endif else begin        ;Assume must be palette
  169.     if s[0] ne 2 then message, 'Parameter must be 2D'
  170.     cols = s[1]
  171.     rows = s[2]
  172.     samples = 1
  173.     if (n_elements(red) ne n_elements(green)) or $
  174.         (n_elements(red) ne n_elements(blue)) then $
  175.             message,'Color tables must have same size'
  176.     color = N_elements(red) GT 0
  177.     if color then photo = 3 else photo = 1
  178. endelse
  179.  
  180. if n_elements(orientation) eq 0 then orientation = 0
  181.  
  182. if (!version.os EQ 'MacOS') then begin
  183. openw, lun, filename, /BLOCK, /GET_LUN, MACTYPE = "TIFF"
  184. endif else begin
  185. openw, lun, filename, /BLOCK, /GET_LUN
  186. endelse
  187. header = bytarr(8)        ;The Tiff header
  188.  
  189. if keyword_set(long) then nbits = 32 $   ;Type of data for samples
  190. else if keyword_set(short) then nbits = 16 $
  191. else nbits = 8
  192. fcn_name = (['BYTE','FIX','', 'LONG'])[nbits/8-1]  ;Sample conversion function
  193.  
  194. tst = byte(1,0,2)        ;Which endian???
  195. if tst[0] eq 1 then header[0] = byte("II") $    ;Little endian
  196.    else header[0] = byte("MM")    ;Big endian
  197.  
  198. header[2] = byte(42,0,2)    ;Version = 42
  199.  
  200. writeu, lun, header
  201.  
  202. ifd = bytarr(512)        ;Image file directory
  203. count = 0            ;# of tags
  204.  
  205. tiff_add_tag, lun, 254, 0L        ;New Subfile type
  206. tiff_add_tag, lun, 256, long(cols)    ;Image width
  207. tiff_add_tag, lun, 257, long(rows)    ;Image height
  208.  
  209. tiff_add_tag, lun, 258, replicate(nbits,samples)  ;bit/sample
  210. tiff_add_tag, lun, 259, 1        ;No compression
  211. tiff_add_tag, lun, 262, photo    ;Photometric Interpretation
  212. nbytes = rows * cols * (nbits/8)    ;Bytes / plane
  213.  
  214. ; Write image data......
  215. point_lun, -lun, faddr        ;Get current file position
  216. if PlanarConfig eq 2 then begin ; write R,G,B in separate planes
  217.     tiff_add_tag, lun, 273, faddr + [0,1,2] * nbytes + 12  ;Strip offsets
  218.     writeu, lun, call_function(fcn_name, red)
  219.     writeu, lun, call_function(fcn_name, green)
  220.     writeu, lun, call_function(fcn_name, blue)
  221. endif else begin        ;Write image as one chunk
  222.     tiff_add_tag, lun,273, faddr  ;Strip offset
  223.     writeu, lun, call_function(fcn_name, array)
  224. endelse
  225.  
  226. tiff_add_tag, lun, 274, fix(4 - 3 * (orientation and 1)) ;Orientation  
  227. tiff_add_tag, lun, 277, samples    ;Samples / pixel
  228. tiff_add_tag, lun, 278, rows        ;Rows / strip
  229.  
  230. if PlanarConfig eq 2 then  t = replicate(nbytes, samples) $ ;Strip byte cnts
  231. else t = samples * nbytes
  232. tiff_add_tag, lun, 279,  t  ;Strip byte counts 
  233.  
  234. if n_elements(xresol) le 0 then xresol = 100.
  235. if n_elements(yresol) le 0 then yresol = 100.
  236. tiff_add_tag, lun, 282, float(xresol)        ;Xresolution
  237. tiff_add_tag, lun, 283, float(yresol)        ;... and Yresolution
  238. tiff_add_tag, lun, 284, PlanarConfig ;PlanarConfig
  239.  
  240. IF (photo EQ 3) THEN BEGIN    ;Add colormap?
  241.     rgb_array = intarr(768)    ;Make the color maps
  242.     rgb_array[0] = ishft(fix(red),8)  ;Scale up to 65K max
  243.     rgb_array[256] = ishft(fix(green), 8)
  244.     rgb_array[512] = ishft(fix(blue),8)
  245.     tiff_add_tag, lun, 320, rgb_array
  246.     ENDIF
  247.  
  248.  
  249. point_lun, -lun, faddr        ;Write IFD at and, get addr
  250. ifd[0] = byte(count,0,2)    ;Insert count
  251. writeu, lun, ifd[0: count*12+5] ;Write IFD followed by 4 zero bytes
  252.  
  253. point_lun, lun, 0        ;Rewind to header
  254. header[4] = byte(faddr,0,4)    ;Write ifd offset
  255. writeu, lun, header        ;And save it
  256.  
  257. free_lun,lun            ;Done
  258. end
  259.         
  260.  
  261.